home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Comms Spectacular / MacTCP / Finger 1.3.7 / Tokens / FORTUNE.p < prev    next >
Encoding:
Text File  |  1991-11-20  |  3.0 KB  |  134 lines  |  [TEXT/PJMM]
  1. unit FORTUNE;
  2.  
  3. interface
  4.  
  5.     uses
  6.         ParameterDef;
  7.  
  8.     procedure Main (var p: parameterRecord);
  9.  
  10. implementation
  11.  
  12.     procedure Main (var p: parameterRecord);
  13.         var
  14.             rn: integer;
  15.             count: longInt;
  16.             s: str255;
  17.         function GetAt (off: longInt; var where: integer; var found: boolean): OSErr;
  18.             var
  19.                 oe: OSErr;
  20.                 len: integer;
  21.             function MyFSRead (len: integer; buf: ptr): OSErr;
  22.                 var
  23.                     l: longInt;
  24.                     oe: OSErr;
  25.             begin
  26.                 l := len;
  27.                 oe := FSRead(rn, l, buf);
  28.                 if oe = eofErr then
  29.                     oe := noErr;
  30.                 if (oe = noErr) and (len <> l) then
  31.                     oe := eofErr;
  32.                 MyFSRead := oe;
  33.             end;
  34.         begin
  35.             len := 255;
  36.             if len > count - off then
  37.                 len := count - off;
  38. {$PUSH}
  39. {$R-}
  40.             s[0] := chr(len);
  41. {$POP}
  42.             if len <= 0 then
  43.                 oe := -1
  44.             else
  45.                 oe := SetFPos(rn, fsFromStart, off);
  46.             if oe = noErr then
  47.                 oe := MyFSRead(len, @s[1]);
  48.             if oe <> noErr then
  49.                 s := '';
  50.             where := Pos(concat(chr(13), '#', chr(13)), s);
  51.             found := where > 0;
  52.             GetAt := oe;
  53.         end;
  54.         procedure AddStr (where: integer);
  55.         begin
  56.             if where > p.hlength - p.offset then
  57.                 where := p.hlength - p.offset;
  58.             if where > 0 then begin
  59.                 BlockMove(@s[1], ptr(longInt(p.fingeroutput^) + p.offset), where);
  60.                 p.offset := p.offset + where;
  61.             end;
  62.         end;
  63.         function Rand (var rnd1, rnd2: longInt; n: integer): longInt;
  64.             var
  65.                 r2: longInt;
  66.         begin
  67.             r2 := BXOR(BOR(BAND(BSR(rnd1, 1), $7FFF), BSL(rnd2, 31)), BSL(rnd1, 12));
  68.             rnd2 := BAND(rnd1, 1);
  69.             rnd1 := BXOR(r2, BAND(BSR(r2, 20), $00000FFF));
  70.             Rand := BAND(rnd1, $7FFFFFFF) mod n;
  71.         end;
  72.  
  73.         var
  74.             oe, ooe: OSErr;
  75.             pos: longInt;
  76.             found: boolean;
  77.             where: integer;
  78.             rnd1, rnd2: longInt;
  79.     begin
  80.         s := p.param^;
  81.         if s = '' then
  82.             s := ':Preferences:Fortune';
  83.         oe := FSOpen(s, 0, rn);
  84.         if oe = noErr then begin
  85.             oe := GetEOF(rn, count);
  86.             if oe = noErr then begin
  87. { Can't use Random because we have no A5 world in the daemon }
  88.                 rnd1 := TickCount;
  89.                 rnd2 := 1;
  90. { TickCount isn't a very good seed, and we reseed it every time we are called, so }
  91. { call Rand several times to produce a more visually random sequence (probably the}
  92. { sequence isn't very random, but it should be good enough) }
  93.                 pos := Rand(rnd1, rnd2, count);
  94.                 pos := Rand(rnd1, rnd2, count);
  95.                 pos := Rand(rnd1, rnd2, count);
  96.                 pos := Rand(rnd1, rnd2, count);
  97. { Asert 0<=pos<count }
  98.                 if pos > count - 3 then
  99.                     pos := count - 3;
  100.                 found := false;
  101.                 repeat
  102.                     oe := GetAt(pos, where, found);
  103.                     if oe = noErr then
  104.                         if found then begin
  105.                             pos := pos + where + 2;
  106.                             if pos >= count then
  107.                                 pos := pos - count;
  108.                         end
  109.                         else begin
  110.                             pos := pos + 250;
  111.                             if pos > count then
  112.                                 oe := -1;
  113.                         end;
  114.                 until found or (oe <> noErr);
  115.                 if found then begin
  116.                     found := false;
  117.                     repeat
  118.                         oe := GetAt(pos, where, found);
  119.                         if oe = noErr then begin
  120.                             if not found then
  121.                                 where := 250
  122.                             else
  123.                                 where := where - 1;
  124.                             AddStr(where);
  125.                             pos := pos + where;
  126.                         end;
  127.                     until found;
  128.                 end;
  129.             end;
  130.             ooe := FSClose(rn);
  131.         end;
  132.     end;
  133.  
  134. end.